home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLSYM.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-01-02  |  4.6 KB  |  205 lines
  1. /* xlsym - symbol handling routines */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *oblist;
  7. extern NODE *s_unbound;
  8. extern NODE *xlstack;
  9.  
  10. /* forward declarations */
  11. FORWARD NODE *xlmakesym();
  12. FORWARD NODE *findprop();
  13.  
  14. /* xlenter - enter a symbol into the oblist */
  15. NODE *xlenter(name,type)
  16.   char *name;
  17. {
  18.     NODE *oldstk,*lsym,*nsym,newsym;
  19.     int cmp;
  20.  
  21.     /* check for nil */
  22.     if (strcmp(name,"nil") == 0)
  23.     return (NULL);
  24.  
  25.     /* check for symbol already in table */
  26.     lsym = NULL;
  27.     nsym = oblist->n_symvalue;
  28.     while (nsym) {
  29.     if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
  30.         break;
  31.     lsym = nsym;
  32.     nsym = cdr(nsym);
  33.     }
  34.  
  35.     /* check to see if we found it */
  36.     if (nsym && cmp == 0)
  37.     return (car(nsym));
  38.  
  39.     /* make a new symbol node and link it into the oblist */
  40.     oldstk = xlsave(&newsym,NULL);
  41.     newsym.n_ptr = newnode(LIST);
  42.     rplaca(newsym.n_ptr,xlmakesym(name,type));
  43.     rplacd(newsym.n_ptr,nsym);
  44.     if (lsym)
  45.     rplacd(lsym,newsym.n_ptr);
  46.     else
  47.     oblist->n_symvalue = newsym.n_ptr;
  48.     xlstack = oldstk;
  49.  
  50.     /* return the new symbol */
  51.     return (car(newsym.n_ptr));
  52. }
  53.  
  54. /* xlsenter - enter a symbol with a static print name */
  55. NODE *xlsenter(name)
  56.   char *name;
  57. {
  58.     return (xlenter(name,STATIC));
  59. }
  60.  
  61. /* xlintern - intern a symbol onto the oblist */
  62. NODE *xlintern(sym)
  63.   NODE *sym;
  64. {
  65.     NODE *oldstk,*lsym,*nsym,newsym;
  66.     char *name;
  67.     int cmp;
  68.  
  69.     /* get the symbol's print name */
  70.     name = xlsymname(sym);
  71.  
  72.     /* check for nil */
  73.     if (strcmp(name,"nil") == 0)
  74.     return (NULL);
  75.  
  76.     /* check for symbol already in table */
  77.     lsym = NULL;
  78.     nsym = oblist->n_symvalue;
  79.     while (nsym) {
  80.     if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
  81.         break;
  82.     lsym = nsym;
  83.     nsym = cdr(nsym);
  84.     }
  85.  
  86.     /* check to see if we found it */
  87.     if (nsym && cmp == 0)
  88.     return (car(nsym));
  89.  
  90.     /* link the symbol into the oblist */
  91.     oldstk = xlsave(&newsym,NULL);
  92.     newsym.n_ptr = newnode(LIST);
  93.     rplaca(newsym.n_ptr,sym);
  94.     rplacd(newsym.n_ptr,nsym);
  95.     if (lsym)
  96.     rplacd(lsym,newsym.n_ptr);
  97.     else
  98.     oblist->n_symvalue = newsym.n_ptr;
  99.     xlstack = oldstk;
  100.  
  101.     /* return the symbol */
  102.     return (sym);
  103. }
  104.  
  105. /* xlmakesym - make a new symbol node */
  106. NODE *xlmakesym(name,type)
  107.   char *name;
  108. {
  109.     NODE *oldstk,sym,*str;
  110.  
  111.     /* create a new stack frame */
  112.     oldstk = xlsave(&sym,NULL);
  113.  
  114.     /* make a new symbol node */
  115.     sym.n_ptr = newnode(SYM);
  116.     sym.n_ptr->n_symvalue = (*name == ':' ? sym.n_ptr : s_unbound);
  117.     sym.n_ptr->n_symplist = newnode(LIST);
  118.     rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
  119.     str->n_str = (type == DYNAMIC ? strsave(name) : name);
  120.     str->n_strtype = type;
  121.  
  122.     /* restore the previous stack frame */
  123.     xlstack = oldstk;
  124.  
  125.     /* return the new symbol node */
  126.     return (sym.n_ptr);
  127. }
  128.  
  129. /* xlsymname - return the print name of a symbol */
  130. char *xlsymname(sym)
  131.   NODE *sym;
  132. {
  133.     return (car(sym->n_symplist)->n_str);
  134. }
  135.  
  136. /* xlgetprop - get the value of a property */
  137. NODE *xlgetprop(sym,prp)
  138.   NODE *sym,*prp;
  139. {
  140.     NODE *p;
  141.  
  142.     return ((p = findprop(sym,prp)) ? car(p) : NULL);
  143. }
  144.  
  145. /* xlputprop - put a property value onto the property list */
  146. xlputprop(sym,val,prp)
  147.   NODE *sym,*val,*prp;
  148. {
  149.     NODE *oldstk,p,*pair;
  150.  
  151.     if ((pair = findprop(sym,prp)) == NULL) {
  152.     oldstk = xlsave(&p,NULL);
  153.     p.n_ptr = newnode(LIST);
  154.     rplaca(p.n_ptr,prp);
  155.     rplacd(p.n_ptr,pair = newnode(LIST));
  156.     rplaca(pair,val);
  157.     rplacd(pair,cdr(sym->n_symplist));
  158.     rplacd(sym->n_symplist,p.n_ptr);
  159.     xlstack = oldstk;
  160.     }
  161.     rplaca(pair,val);
  162. }
  163.  
  164. /* xlremprop - remove a property from a property list */
  165. xlremprop(sym,prp)
  166.   NODE *sym,*prp;
  167. {
  168.     NODE *last,*p;
  169.  
  170.     last = NULL;
  171.     for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
  172.     if (car(p) == prp)
  173.         if (last)
  174.         rplacd(last,cdr(cdr(p)));
  175.         else
  176.         rplacd(sym->n_symplist,cdr(cdr(p)));
  177.     last = cdr(p);
  178.     }
  179. }
  180.  
  181. /* findprop - find a property pair */
  182. LOCAL NODE *findprop(sym,prp)
  183.   NODE *sym,*prp;
  184. {
  185.     NODE *p;
  186.  
  187.     for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  188.     if (car(p) == prp)
  189.         return (cdr(p));
  190.     return (NULL);
  191. }
  192.  
  193. /* xlsinit - symbol initialization routine */
  194. xlsinit()
  195. {
  196.     /* initialize the oblist */
  197.     oblist = xlmakesym("*oblist*",STATIC);
  198.     oblist->n_symvalue = newnode(LIST);
  199.     rplaca(oblist->n_symvalue,oblist);
  200.  
  201.     /* enter the unbound symbol indicator */
  202.     s_unbound = xlsenter("*unbound*");
  203.     s_unbound->n_symvalue = s_unbound;
  204. }
  205.